perm filename INITIA[MAC,LSP]2 blob
sn#451455 filedate 1979-06-15 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00012 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002
C00005 00003
C00016 00004
C00019 00005
C00024 00006
C00028 00007
C00033 00008
C00038 00009
C00042 00010
C00046 00011
C00049 00012 β
C00050 ENDMK
C⊗;
;;; INITIA -*-LISP-*-
;;; **************************************************************
;;; ***** MACLISP ***** (Initialization for COMPLR) *************
;;; **************************************************************
;;; ** (C) Copyright 1979 Massachusetts Institute of Technology **
;;; ****** This is a Read-Only file! (All writes reserved) *******
;;; **************************************************************
(DEFUN CMPTIME-EVAL MACRO (X) (AND (EVAL (CADR X)) (EVAL (CADDR X))))
(CMPTIME-EVAL 'T
`(SETQ INITIAVERNO ',(cond ((caddr (truename infile)))
('/28))))
(EVAL-WHEN (COMPILE)
(AND (OR (NOT (GET 'COMPDECLARE 'MACRO))
(NOT (GET 'FREEAC)))
(LOAD (LIST (COND ((STATUS FEATURE ITS) '(DSK COMLAP))
((STATUS FEATURE DEC20) '(DSK MACLISP))
((STATUS FEATURE SAIL) '(DSK (MAC LSP)))
((STATUS FEATURE D10) '(LISP MACLISP))
('T (BREAK WHERE-IS-CDMACS) '(* *)))
'CDMACS
'FASL))))
(EVAL-WHEN (COMPILE) (COMPDECLARE) (FASLDECLARE) (GENPREFIX |/|in|) )
(EVAL-WHEN (EVAL) (SETQ CAR 'T))
(AND (NOT (STATUS FEATURE SAIL))
(MAPC '(LAMBDA (X)
(LET (((TYPE FUN . L) X) (PROP))
(SETQ PROP (GET FUN TYPE))
(MAPC '(LAMBDA (X) (AND (NOT (GET X TYPE))
(PUTPROP X PROP TYPE)))
L)))
'((FSUBR UREAD EREAD) (LSUBR OPEN EOPEN) (SUBR LOAD ELOAD))))
(COMMENT INITIALIZING FUNCTIONS)
(DEFUN INITIALIZE FEXPR (L)
(SSTATUS FEATURE COMPLR)
(SSTATUS FEATURE NCOMPLR)
(SETQ OPSYS (COND ((STATUS FEATURE ITS) 'ITS )
((STATUS FEATURE SAIL) 'SAIL)
((STATUS FEATURE DEC20) 'DEC20)
((STATUS FEATURE DEC10) 'DEC10)
((BARF () |WHAT OPERATING SYSTEM?|))))
(SETQ MAKLAP-DEFAULTF-STYLE 'MIDAS)
(SETQ OBARRAY (SETQ SOBARRAY (GET 'OBARRAY 'ARRAY)))
(SETQ READTABLE (SETQ SREADTABLE (GET 'READTABLE 'ARRAY)))
(SETQ SWITCHTABLE ;Setup before INTERNing
(APPEND '(
(/$ FLOSW ()) (/+ FIXSW ())
(A ASSEMBLE () ) (C CLOSED () )
(D DISOWNED () ) (E EXPR-HASH () )
(F FASL #,(AND (MEMQ COMPILER-STATE '(MAKLAP DECLARE)) T))
(G GAG-ERRBREAKS () ) (H EXPAND-OUT-MACROS T)
(/2 HUNK2-TO-CONS ()) (I INITIALIZE () )
(K NOLAP #,(AND (MEMQ COMPILER-STATE '(MAKLAP DECLARE)) T))
(M MACROS () ) (O ARRAYOPEN T) (S SPECIALS () )
(T TTYNOTES #,(AND (NOT (MEMQ COMPILER-STATE
'(MAKLAP DECLARE))) T))
(W MUZZLED () ) (X MAPEX () )
(Y YESWARNTTY #,(AND (NOT (MEMQ COMPILER-STATE
'(MAKLAP DECLARE))) T) )
(Z SYMBOLS () )
)
()))
(PUSH (COND (#(SAILP)
(SETQ MAKLAP-DEFAULTF-STYLE () )
'(U UNFASLCOMMENTS () ))
( '(U UNFASLCOMMENTS T)))
SWITCHTABLE)
(DO I 65. (1+ I) (> I 90.)
(AND (NOT (ASSQ (ASCII I) SWITCHTABLE))
(PUSH (LIST (ASCII I)
(IMPLODE (APPEND '(S W I T C H /-) (LIST (ASCII I))))
() )
SWITCHTABLE)))
(COND ((STATUS FEATURE NO-EXTRA-OBARRAY)
(SETQ CREADTABLE READTABLE COBARRAY OBARRAY))
('T (SETQ CREADTABLE (ARRAY
()
READTABLE
(COND ((AND (BOUNDP 'IREADTABLE)
(EQ (TYPEP IREADTABLE) 'ARRAY)
(EQ (CAR (ARRAYDIMS IREADTABLE))
'READTABLE))
IREADTABLE)
('T))))
(SETQ COBARRAY (ARRAY
()
OBARRAY
(COND ((AND (BOUNDP 'IOBARRAY)
(EQ (TYPEP IOBARRAY) 'ARRAY)
(EQ (CAR (ARRAYDIMS IOBARRAY))
'OBARRAY))
IOBARRAY)
((GET 'OBARRAY 'ARRAY)))))
(LET ((OBARRAY COBARRAY) (READTABLE CREADTABLE))
(MAPC 'INTERN
'(
*EXPR *FEXPR *LEXPR @DEFINE ARRAY* CHOMP CHOMPHOOK
CMSGFILES COBARRAY COMPILE COMPLR COMPLRVERNO
COUTPUT CREADTABLE DIRECTORY EOC-EVAL GENPREFIX
GOFOO MACROLIST MAKLAP MSDEV MSDIR NCOMPLR
NO-EXTRA-OBARRAY NOTYPE NUMFUN NUMVAR ONMLS
OWN-SYMBOL RECOMPL SKIP-WARNING SOBARRAY SPECIAL
SPLITFILE SQUID SREADTABLE SWITCHTABLE TOPLEVEL
UNDFUNS UNSPECIAL MACRO-EXPAND
))
(MAPC '(LAMBDA (X) (INTERN (CADR X))) SWITCHTABLE)
(MAPC 'INTERN SAIL-MORE-SYSFUNS)
(AND #(SAILP) (SETSYNTAX '/" 'MACRO '%%%STRING%%%) ))))
(SETSYNTAX '/& 'MACRO 'MACR-AMP-FUN)
(AND #(SAILP) (SETSYNTAX '/" 'MACRO '%%%STRING%%%))
#(LET ((PROP (LSUB '(MACRO SPECIAL ARGS *EXPR *FEXPR *LEXPR
NUMVAR NUMFUN *ARRAY OHOME SKIP-WARNING)
L))
(Z () ))
(MAPATOMS '(LAMBDA (Y)
(LREMPROP Y PROP) ;Remove compilation
(COND ((SETQ DATA (GET Y 'FUNTYP-INFO)) ;properties.
(COND ((ARGS Y))
((GET Y (CAR DATA)) (ARGS Y (CDR DATA)))
('T (PUTPROP Y (CDR DATA) 'ARGS))))
((NOT (SYSP Y)) (ARGS Y () )))
(AND (BOUNDP Y) ;SPECIALize the
(NOT (MEMQ Y '(T NIL))) ;system varialbes
(SETQ DATA Y)
(MEMQ 'VALUE (STATUS SYSTEM DATA))
(PUSH Y Z))))
(APPLY 'SPECIAL Z)
(FASLINIT))
(PUTPROP '%HUNK1 '(() . 1) 'ARGS)
(PUTPROP '%HUNK2 '(() . 2) 'ARGS)
(PUTPROP '%HUNK3 '(() . 3) 'ARGS)
(PUTPROP '%HUNK4 '(() . 4) 'ARGS)
(SETQ PRINLEVEL (SETQ PRINLENGTH (SETQ *RSET () )))
(SETQ BASE 8. IBASE 8. *NOPOINT 'T)
(SETQ COMPILATION-FLAGCONVERSION-TABLE
'((EXPR . SUBR) (FEXPR . FSUBR) (LEXPR . LSUBR)))
(SETQ SPECVARS () GENPREFIX '(/| G) GFYC 0 P1GFY ()
CLOSED () FIXSW () FLOSW () MACROLIST ()
GAG-ERRBREAKS () RNL () CFVFL ()
UNDFUNS () P1LLCEK () LAPLL () ROSENCEK ()
FASLPUSH () RECOMPL () CMSGFILES () LAP-INSIGNIF 'T
EOC-EVAL () COMPILER-STATE 'TOPLEVEL CHOMPHOOK ()
TOPFN () ONMLS () READ () MSDEV 'DSK MSDIR ()
CL () CLEANUPSPL 0 FILESCLOSEP () IMOSAR () )
#(SETUP-CATCH-PDL-COUNTS)
(MAPC '(LAMBDA (X) (SET (CADR X) (CADDR X))) SWITCHTABLE)
(MAPC '(LAMBDA (X) (SET X (COPYSYMBOL X () )))
'(PROGN GOFOO NULFU COMP CARCDR ARGLOC SQUID MAKUNBOUND))
(PUTPROP SQUID '(LAMBDA (GL) (LIST 'QUOTE GL)) 'MACRO)
(SETQ QSM (LIST (LIST 'QUOTE (LIST SQUID MAKUNBOUND))))
(SETQ STSL (LIST (DELQ 'TERPR (STATUS STATUS))
(DELQ 'TERPR (STATUS SSTATUS))))
(SETQ ARGLOC (LIST ARGLOC) CLPROGN (LIST PROGN))
(SETQ CAAGL (LIST (LIST (CONS MAKUNBOUND ARGLOC) 1)
(LIST (CONS MAKUNBOUND ARGLOC) 2)))
(SETQ MAPSB (NCONC (MAPCAR 'LIST '(VL EXIT EXITN PVR STSL))
(LIST (CONS 'GOFOO GOFOO))))
(SETQ COMAL (SUBST '() 'NIL '((NIL . NIL) (FIXNUM . FIXNUM) (FLONUM . FLONUM) (T))) )
(RPLACD (CAR COMAL) (CAR COMAL)) ;Sets up infinite
(RPLACD (CADR COMAL) (CADR COMAL)) ; type lists for COMARITH
(RPLACD (CADDR COMAL) (CADDR COMAL))
(FIXNUM BASE IBASE BPORG BPEND TTY) ;Some known declarations
(FIXNUM (LENGTH) (RANDOM) (EXAMINE FIXNUM) (LISTEN) (RUNTIME)
(GETCHARN NOTYPE FIXNUM) (FLATSIZE) (FLATC) (LSH) (ROT) (IFIX)
(↑ FIXNUM FIXNUM) (\\ FIXNUM FIXNUM) (SXHASH) (TYIPEEK) (TYI)
(HAULONG))
(FIXNUM (IN) (LINEL) (PAGEL) (CHARPOS) (LINENUM) (PAGENUM) (LENGTHF))
(PUTPROP 'BOOLE (CONS (CADR COMAL) (CONS 'FIXNUM (CADR COMAL))) 'NUMFUN)
(FLONUM (SIN) (COS) (SQRT) (LOG) (EXP) (ATAN) (TIME)
(↑$ FLONUM FIXNUM) (FSC) (FLOAT))
(NOTYPE (GETCHAR NOTYPE FIXNUM) (CXR FIXNUM) (DEPOSIT FIXNUM))
(ARRAY* (NOTYPE OBARRAY 1 READTABLE 1))
(PUTPROP PROGN 'T '*LEXPR)
(MAPC '(LAMBDA (X) (PUTPROP X (INTERN (PNAMECONC X '| | 'MACRO)) 'MACRO))
(COND (#(SAILP)
(MAPC '(LAMBDA (X) (PUTPROP X 'T 'SKIP-WARNING))
'(PUSH POP LET))
(SSTATUS TTYINT 200. (STATUS TTYINT 194.))
(SSTATUS TTYINT 467. 'S-C)
'(LET LET* DESETQ DEFUN/& DEFMACRO MACROEXPANDED |MACRO-macroexpander/||
MACRO MACRODEF TRANS TRANSDEF |`-expander/||))
('(LET LET* DESETQ DEFUN/& MACRO DEFMACRO DEFMACRO-DISPLACE
MACROEXPANDED |MACRO-macroexpander/|| |`-expander/||))))
(PUTPROP '|`,/|| '|+INTERNAL-macro-loser/|| 'MACRO)
(PUTPROP '|`,@/|| '|+INTERNAL-macro-loser/|| 'MACRO)
(PUTPROP '|`,./|| '|+INTERNAL-macro-loser/|| 'MACRO)
(SSTATUS TTYINT '/≡ 'INT-↑↑-FUN)
(SSTATUS TTYINT '/¬ 'INT-↑↑-FUN)
(SETQ OBARRAY #,(COND ((MEMQ COMPILER-STATE '(MAKLAP DECLARE)) 'COBARRAY)
('SOBARRAY)))
(SETQ READTABLE #,(COND ((MEMQ COMPILER-STATE '(MAKLAP DECLARE)) 'CREADTABLE)
('SREADTABLE)))
(GCTWA))
;;; Function for & macro char
(DEFUN MACR-AMP-FUN ()
((LAMBDA (OBARRAY READTABLE)
(COND ((= (TYIPEEK) #,(INVERSE-ASCII '/&))
(TYI)
(SETQ OBARRAY SOBARRAY READTABLE SREADTABLE)))
(READ))
COBARRAY CREADTABLE))
;;; Function for control-↑ interrupt
(DEFUN INT-↑↑-FUN N
(SETQ SAVED-ERRLIST ERRLIST ERRLIST () N (ARG 2))
(SSTATUS TOPLEVEL '(INT-↑↑-TOPLE))
(DO () ((OR (= (LISTEN) 0) (= (TYI) N))))
(↑G))
(DEFUN INT-↑↑-TOPLE () ;Starts up MAKLAP from ↑↑
#(ERL-SET)
(SSTATUS TOPLEVEL () )
(COMPLRVERNO)
(NOINTERRUPT () )
(MAKLAP))
(DEFUN DB FEXPR (L) ;Setup for debugging
L
(SETQ SAVED-ERRLIST ERRLIST ERRLIST () )
(SSTATUS TOPLEVEL '(DB-TOPLE))
(↑G))
(DEFUN DB-TOPLE ()
(SSTATUS UUOLI)
#(ERL-SET)
(*RSET (NOUUO 'T))
(SETQ OBARRAY SOBARRAY READTABLE SREADTABLE)
(SETQ ↑W (SETQ ↑R () ))
(SETQ ERRSET (FUNCTION (LAMBDA (X) X (BREAK ERRSET))))
(PROG (L)
A (COND ((NOT (GET 'BS 'FSUBR))
(COND (#(ITSP) (SETQ L '((DSK LIBLSP) BS FASL)))
((PROBEF (SETQ L '((DSK) BS FAS))))
('T (PRINC '|/
PLEASE LOAD BS FASL! /
|)
(BREAK LOAD)
(GO A)))
(ELOAD L))))
(SSTATUS TOPLEVEL () ))
(DEFUN S-C (() ()) (CDUMP '|SAVE COMPLR|))
;This function never returns, but is a way to start up the toplevel complr
(DEFUN CDUMP N
(SETQ ERRLIST () SAVED-ERRLIST '((COMPLRVERNO)))
(SSTATUS TOPLEVEL '(COMPLR-TOPLE))
(SETQ CDUMP (LISTIFY N))
(THROW () ())
;;(COMMENT Hopefully, this goes to a TOPLEVEL user of COMPLR-TOPLE)
)
(DEFUN COMPLR-TOPLE () ;Initial TOPLEVEL loop
(SETQ OBARRAY COBARRAY READTABLE CREADTABLE)
(SSTATUS TOPLEVEL () )
(SETQ - () + () )
#(ERL-SET)
(GCTWA 1)
(GC)
(APPLY 'SUSPEND CDUMP)
#(LET ((UID (STATUS USERID))
(USN (COND ((STATUS STATUS HOMED) (STATUS HOMED)) ((STATUS UDIR))))
(MSGFILES '(T))
(COMPILER-STATE 'DECLARE)
FILE OFILE)
(SETQ OFILE (CONS (LIST 'DSK USN)
(COND (#(ITSP) (CONS UID '(COMPLR)))
('(COMPLR INI))))) ;`((DSK ,usn) ,uid COMPLR)
(AND (COND ((SETQ FILE (PROBEF OFILE)))
(#(ITSP)
(RPLACA (CDR OFILE) '*)
(AND (SETQ FILE (CAR (ERRSET (EOPEN OFILE '(NODEFAULT))
() )))
(SETQ FILE (TRUENAME FILE)))
FILE))
(PRINC '|LOADING COMPLR INITIALIZATION FILE FOR |)
(PRINC (COND ((OR (EQ (CADR OFILE) '*) (NOT #(ITSP))) USN)
(UID)))
(PROG2 (TERPRI) 'T)
(AND (ATOM (ERRSET (ELOAD FILE) 'T))
(PRINC '| *** ERRORS DURING LOADING *** BEWARE!| TYO)))
(SETQ DEFAULTF (LIST (LIST (COND (#(DEC20P) 'PS) ('DSK))
(STATUS UDIR))
'FOO
(COND (#(ITSP) '>)
(#(SAILP) '|←←←|)
('LSP))))
(COND ((SETQ DATA (STATUS JCL))
(LET (WINP (JCL-LINE DATA))
(SSTATUS FEATURE NOLDMSG)
(SETQ WINP
(ERRSET
(PROG (M L LL)
(SETQ L DATA)
A (AND (< (SETQ M (GETCHARN (CAR L) 1)) 27.) ;Flush control chars
(NOT (= M 17.)) ;[except ↑Q] from
(SETQ L (CDR L)) ;front of JCL list
(GO A))
(SETQ LL ())
B (SETQ M (GETCHARN (CAR L) 1))
(PUSH (COND ((AND (< M 123.) (> M 96.))
(- M 32.)) ;Uppercaseify rest
(M)) ;of line
LL)
(AND (SETQ L (CDR L)) (GO B))
C (AND (< (CAR LL) 27.)
(SETQ LL (CDR LL)) ;Flush control chars
(GO C)) ;from end of line
(APPLY 'MAKLAP (NREVERSE LL)))
'T ))
(COND ((ATOM WINP)
(COND (WINP (PRINC '| *** ERRORS FROM JCL COMMAND *** /
;JCL = "|)
(PRINC (MAKNAM JCL-LINE))
(PRINC '|"/
|)
(BREAK JCL))
('T (PRINC '| *** ERRORS - RANDOMNESS IN COMPLR-TOPLE|)
(BREAK COMPLR-TOPLE))) ))
(INT-↑↑-TOPLE)))
('T (COMPLRVERNO) (MAKLAP)))) )
;;; NOTE: THE LIST OF GLOBALSYMS SHOULD CORRESPOND TO
;;; THE LIST OF SYMBOLS AT LOCATION LSYMS IN LISP.
(DEFUN FASLINIT ()
(GETMIDASOP ())
((LAMBDA (OBARRAY PROPS ACS FL)
(MAPATOMS '(LAMBDA (X) (LREMPROP X PROPS)))
(SETQ LDFNM (FASLAPSETUP/| () )) ;Sets up GLOBALSYMS
(COND ((AND (BOUNDP 'COBARRAY)
(EQ (TYPEP COBARRAY) 'ARRAY)
(SETQ FL (ARRAYDIMS COBARRAY))
(EQ (CAR FL) 'OBARRAY)
(NOT (AND (BOUNDP 'SOBARRAY) (EQ SOBARRAY COBARRAY))))
(SETQ FL '(% @ BLOCK ASCII SIXBIT SQUOZE CALL NCALL JCALL NJCALL
ENTRY DEFSYM BLOCK SYMBOLS BEGIN DDTSYM
THIS IS THE UNFASL FOR LISP FILE COMPILED BY COMPILER))
(MAPATOMS '(LAMBDA (X) (AND (GETL X '(SYM GLOBALSYM)) (PUSH X FL))))
;;;AFTER THE FASLAPSETUP/|, ONLY SYMS SHOULD BE GLOBALSYMS. IN ORDER:
;*SET *MAP PRINTA SPECBIND UNBIND IOGBND *LCALL *UDT ARGLOC
;INUM ST FXNV1 PDLNMK PDLNKJ FIX1A FIX1 FLOAT1 IFIX IFLOAT
;FXCONS FLCONS ERSETUP ERUNDO GOBRK CARCDR *STORE NPUSH PA3
;MAKUNBOUND FLTSKP FXNV2 FXNV3 FXNV4 FIX2 FLOAT2 AREGET
;UINITA UTIN INTREL INHIBIT NOQUIT CHECKI 0PUSH 0*0PUSH
;NILPROPS VBIND %CXR %RPX
(SETQ OBARRAY COBARRAY)
(MAPC 'INTERN FL) ;Cross-interns GLOBALSYMS
(MAPC 'INTERN (APPEND PROPS ACS))) ;Plus a few other words
(T (SETQ COBARRAY OBARRAY CREADTABLE READTABLE)))
(SETQ SQUIDP ()) ;Lists and set up GLOBALSYMS
(DO ((I 0 (1+ I)) (L ACS (CDR L))) ;Now define SYMS for LISP acs
((NULL L))
(AND (NOT (EQ (CAR L) 'FOO)) (PUTPROP (CAR L) I 'SYM)))
(ARRAY LCA T 16.) (ARRAY NUMBERTABLE T 127.)
(ARRAY BTAR FIXNUM 9.) (ARRAY BXAR FIXNUM 9.) (ARRAY BSAR T 9.)
(DO I 0 (1+ I) (= I 16.) (STORE (LCA I) (CONS I '((() -1)))))
(SETQ IMOSAR () IMOUSR ())
(SSTATUS FEATURE FASLAP)
(GCTWA))
OBARRAY
'(SYM ATOMINDEX ARGSINFO ENTRY GLOBALSYM)
'(FOO A B C AR1 AR2A T TT D R F FOO P FLP FXP SP)
()))
(COMMENT FILL INITIAL ARRAYS)
(ARRAY AC-ADDRS T #,(+ (NUMVALAC) (NUMNACS) 1))
(ARRAY PDL-ADDRS T 3 #,(+ 1 (NPDL-ADDRS)))
(ARRAY STGET T #,(+ (NUMVALAC) (NUMNACS)))
(ARRAY BOLA T #,(+ (NACS) (NUMNACS) 1) 7)
(ARRAY CBA T 16.)
(ARRAY A1S1A T #,(NUMNACS) 4)
(ARRAY PVIA T 3 (1+ (MAX #,(MAX-NPUSH) #,(MAX-0PUSH) #,(MAX-0*0PUSH))))
(PROGN (DO CNT #,(+ (NUMVALAC) (NUMNACS)) (1- CNT) (< CNT 1) ;Sets AC-ADDRS
(STORE (AC-ADDRS CNT) CNT))
(DO CNT #,(NPDL-ADDRS) (1- CNT) (< CNT 1) ;Sets PDL-ADDRS
(STORE (PDL-ADDRS 0 CNT) (- CNT #,(NPDL-ADDRS)))
(STORE (PDL-ADDRS 1 CNT) (- (+ CNT #,(FXP0)) #,(NPDL-ADDRS)))
(STORE (PDL-ADDRS 2 CNT) (- (+ CNT #,(FLP0)) #,(NPDL-ADDRS))))
;;; (STGET n) is for accessing segment table into register n
(DO CNT #,(+ (NUMVALAC) (NUMNACS) -1) (1- CNT) (< CNT 1)
(STORE (STGET CNT) (SUBST CNT 'N '(0 ST N))))
(DO ((HLAC #,(+ (NACS) (NUMNACS)) (1- HLAC))
(ATPL (SUBST #,(NUMVALAC) 'AC '((TDZA N N)
(MOVEI N 'T)
(SKIPE 0 N)
(MOVNI AC N)
(MOVEI N '() )
(SKIPN 0 N) ))))
((< HLAC 1))
(DO ((CNT 1 (1+ CNT)) (ATPL1 ATPL (CDR ATPL1)))
((NULL ATPL1))
(STORE (BOLA HLAC CNT) (SUBST HLAC 'N (CAR ATPL1)))))
(FILLARRAY 'CBA '((SETZ) (AND) (ANDCA) (SETA) ;Sets CBA
(ANDCM) (SETM) (XOR) (IOR) (ANDCB)
(EQV) (SETCM) (ORCA) (SETCA)
(ORCM) (ORCB) (SETO)))
(DO CNT #,(- (NUMNACS) 1) (1- CNT) (< CNT 0) ;Sets A1S1A
(DO ((HLAC 0 (1+ HLAC)) (L '((ADDI 1)
(SUBI 1)
(FADRI 66304.) ;66304. = 201400[8]
(FSBRI 66304.))
(CDR L)))
((NULL L))
(STORE (A1S1A CNT HLAC) (LIST (CAAR L)
(+ CNT #,(NUMVALAC))
(CADAR L)))))
;;; Makes up array of JSPs to places that push the appropriate number
;;; of pdl-variable initialization values, onto the appropriate stack.
;;; (PVIA 0 n) ==> (JSP T (NPUSH -n)) pushes ()s onto REGPDL
;;; (PVIA 1 n) ==> (JSP T (0PUSH -n)) pushes 0s onto FXPDL
;;; (PVIA 2 n) ==> (JSP T (0*0PUSH -n)) pushes 0.0s onto FLPDL
(STORE (PVIA 0 0) #,(MAX-NPUSH))
(STORE (PVIA 1 0) #,(MAX-0PUSH))
(STORE (PVIA 2 0) #,(MAX-0*0PUSH))
(STORE (PVIA 0 1) '(PUSH P (% 0 0 '())))
(STORE (PVIA 1 1) '(PUSH FXP (% 0)))
(STORE (PVIA 2 1) '(PUSH FLP (% 0.0)))
(STORE (PVIA 0 2) 'NPUSH)
(STORE (PVIA 1 2) '0PUSH)
(STORE (PVIA 2 2) '0*0PUSH)
(DO CNT 0 (1+ CNT) (> CNT 2)
(DO HLAC (PVIA CNT 0) (1- HLAC) (< HLAC 3)
(STORE (PVIA CNT HLAC) (LIST 'JSP 'T (LIST (PVIA CNT 2) (- HLAC))))))
(COND (*PURE
(MAPC '(LAMBDA (GL)
(SETQ GL (GET GL 'ARRAY))
(DO CNT (1- (CADR (ARRAYDIMS GL))) (1- CNT) (< CNT 0)
(STORE (ARRAYCALL T GL CNT)
(PURCOPY (ARRAYCALL T GL CNT)))))
'(AC-ADDRS STGET CBA))
(MAPC '(LAMBDA (GL)
(SETQ GL (GET GL 'ARRAY))
(DO CNT (1- (CADR (ARRAYDIMS GL))) (1- CNT) (< CNT 0)
(DO HLAC (1- (CADDR (ARRAYDIMS GL)))
(1- HLAC)
(< HLAC 0)
(STORE (ARRAYCALL T GL CNT HLAC)
(PURCOPY (ARRAYCALL T GL CNT HLAC))))))
'(PDL-ADDRS BOLA A1S1A PVIA))))
)
(COMMENT PUT PROPERTIES ON VARIOUS SYMBOLS)
(PROGN (DEFPROP RPLACD (HRRM . HRRM) INST)
(DEFPROP RPLACA (HRLM . HRLM) INST)
(DEFPROP RPLACD (HLLZS . HLLZS) INSTN)
(DEFPROP RPLACA (HRRZS . HRRZS) INSTN)
(DEFPROP SETPLIST (HRRM . HRRM) INST)
(DEFPROP SETPLIST (HLLZS . HLLZS) INSTN)
(DEFPROP A (HLRZ . HLRZ) INST)
(DEFPROP D (HRRZ . HRRZ) INST)
(MAPC '(LAMBDA (INST INSTN) (PUTPROP INST INSTN 'IMMED))
'(MOVE CAMN CAME
ADD SUB IMUL IDIV CAMLE CAMG CAML CAMGE MOVN
AND ORCB SETCM XOR EQV IOR ANDCB ANDCA ANDCM ORCM ORCA)
'(MOVEI CAIN CAIE
ADDI SUBI IMULI IDIVI CAILE CAIG CAIL CAIGE MOVNI
ANDI ORCBI SETCMI XORI EQVI IORI ANDCBI ANDCAI ANDCMI ORCMI ORCAI))
(MAPC '(LAMBDA (INST INSTN) (PUTPROP INST INSTN 'JSP))
'(CONS XCONS NCONS %HUNK1 %HUNK2 %HUNK3 %HUNK4)
'(
(((JSP T %CONS) .
(JSP T %C2NS))
. ((JSP T %PDLC) .
(JSP T %C2NS)))
(((JSP T %XCONS) .
(JSP T %PDLXC))
. PUNT )
(((JSP T %NCONS)) .
((JSP T %PDLNC)))
((JSP T %HUNK1))
((JSP T %HUNK2))
((JSP T %HUNK3))
((JSP T %HUNK4))
))
(MAPC '(LAMBDA (INST INSTN) (PUTPROP INST INSTN 'COMMU) (PUTPROP INSTN INST 'COMMU))
'(CONS *GREAT *PLUS *TIMES EQUAL CAMG CAMGE JUMPGE JUMPL)
'(XCONS *LESS *PLUS *TIMES EQUAL CAML CAMLE JUMPLE JUMPG))
(MAPC '(LAMBDA (INST INSTN) (PUTPROP INST INSTN 'CONV) (PUTPROP INSTN INST 'CONV))
'(JUMP JUMPL JUMPE JUMPLE TRNN TLNN SOJE CAMG CAML
CAMN CAIG CAIL CAIE SKIPE SKIPG SKIPL)
'(JUMPA JUMPGE JUMPN JUMPG TRNE TLNE SOJN CAMLE CAMGE
CAME CAILE CAIGE CAIN SKIPN SKIPLE SKIPGE))
;A status option with no STATUS property means no evaluation of its
; entries. "(x . y)" means "x" is for sstatus and "y" for status;
; x and y are "A" to mean evaluate all but option name, and "B" to
; mean evaluate all but option name and next thing.
(MAPC '(LAMBDA (Z Y) (MAPC '(LAMBDA (X) (PUTPROP X Z 'STATUS)) Y))
'((A . A) (() . A) (A . () ) (B . B))
'((TTY TTYRE TTYTY TTYCO TTYSC TTYIN LINMO PDLMA INTER
GCMIN GCSIZ GCMAX)
(DIVOV FTVSI + TOPLE UUOLI ABBRE GCTIM GCWHO WHO1 WHO2 WHO3
EVALH BREAK MAR CLI FLUSH PUNT RANDO /← LOSEF)
(SYSTE SPCSI PURSI PDLSI PDLRO FILEM TTYSI OSPEE HSNAM)
(MACRO SYNTA CHTRA)))
((LAMBDA (EXLDL GL) (FUNCALL EXLDL () () ))
'(LAMBDA (CARCDR LDLST)
((LAMBDA (EXIT EXITN)
(PUTPROP EXIT (CONS 'A (CONS CARCDR (CAR GL))) 'CARCDR)
(PUTPROP EXITN (CONS 'D (CONS CARCDR (CADR GL))) 'CARCDR)
(SETQ GL (CDDR GL))
(COND ((< (LENGTH LDLST) 3)
(FUNCALL EXLDL EXIT (CONS 'A LDLST))
(FUNCALL EXLDL EXITN (CONS 'D LDLST)))))
(IMPLODE (APPEND '(C A) LDLST '(R)))
(IMPLODE (APPEND '(C D) LDLST '(R)))))
'(6. 14. 5. 13. 19. 24. 27. 33. 36. 30. 3. 11. 17. 22. 1. 9.
4. 12. 18. 23. 26. 32. 35. 29. 2. 10. 16. 21. 0. 8.)) ;BOY! ARE THESE NUMBERS RANDOM!
(MAPC '(LAMBDA (INST INSTN) (PUTPROP INST INSTN 'MINUS))
'(MOVEI ADDI SUBI)
'(MOVNI SUBI ADDI))
(MAPC '(LAMBDA (INST INSTN) (PUTPROP INST INSTN 'BOTH))
'(ADD SUB IMUL IDIV FADR FSBR FDVR FMPR)
'(ADDB SUBB IMULB IDIVB FADRB FSBRB FDVRB FMPRB))
(MAPC '(LAMBDA (INST INSTN) (PUTPROP INST INSTN 'FLOATI))
'(FADR FSBR FMPR FDVR MOVE)
'(FADRI FSBRI FMPRI FDVRI MOVSI))
(MAPC '(LAMBDA (X)
(COND ((GET (CAR X) 'AUTOLOAD)
(AND (CDDR X) (ARGS (CAR X) (CDDR X)))
(AND (CDR X) (PUTPROP (CAR X) (CDR X) 'FUNTYP-INFO)))))
'((ALLFILES SUBR () . 1)
(CGOL FSUBR) (CGOLREAD LSUBR) (CREATE-JOB LSUBR 3 . 5)
(DIRECTORY LSUBR 1 . 2) (FORMAT LSUBR)
(DUMPARRAYS SUBR () . 2) (GETMIDASOP SUBR () . 1)
(GRIND FSUBR) (GRIND0 FSUBR) (GRINDEF FSUBR)
(INDEX) (INF-EDIT)
(LAP FSUBR) (LAP-A-LIST SUBR () . 1)
(LEDIT FSUBR) (LOADARRAYS SUBR () . 1)
(MACROEXPAND SUBR () . 1) (MACROEXPAND-1 SUBR () . 1)
(MAPALLFILES SUBR () . 2) (MAPDIRECTORY LSUBR 2 . 3)
(SORT SUBR () . 2) (SORTCAR SUBR () . 2)
(SPRINTER SUBR () . 1) (TRACE FSUBR)
))
(DEFPROP %CATCHALL (FSUBR) FUNTYP-INFO)
(DEFPROP %PASS-THRU (FSUBR) FUNTYP-INFO)
(MAPC '(LAMBDA (X) (PUTPROP X 'NOTNUMP 'NOTNUMP)) ;Has no side-effects
'(
%HUNK1 %HUNK2 %HUNK3 %HUNK4 *APPEND ALPHALESSP
APPEND ARRAYDIMS ASSOC ASSQ ATOM BAKLIST
BIGP BOUNDP CONS COPYSYMBOL ERRFRAME
EVALFRAME EXPLODE EXPLODEC EXPLODEN
FILEP FIXP FLOATP GETCHAR GETL HUNK
HUNKP LAST LISTARRAY LISTIFY MAKNAM
MEMBER MEMQ NCONS NTHCDR NULL NUMBERP
PLIST PNGET REVERSE SAMEPNAMEP SIGNP
SUBLIS SUBST SYMBOLP SYSP TYPEP XCONS
))
(MAPC '(LAMBDA (X) (PUTPROP X 'EFFS 'NOTNUMP)) ;Has side-effects
'(
*ARRAY *DELETE *DELQ *NCONC *READCH *REARRAY
ALARMCLOCK ASCII CURSORPOS DELETE DELQ DUMPARRAYS
FILLARRAY GENSYM IMPLODE INTERN LOADARRAYS NCONC NRECONC
NREVERSE READCH REMOB REMPROP SASSOC SASSOC SASSQ SETPLIST
SETSYNTAX SORT SORTCAR SUSPEND TERPRI VALRET
))
(MAPC '(LAMBDA (X) (PUTPROP X 'T 'NOTNUMP)) ;Has side-effects, and returns T
'(TYO /+TYO *TYO DEPOSIT PRIN1 PRINC PRINT *PRIN1 *PRINC *PRINT))
;;; In general, function-names with ACS properties have no side-effects, except
;;; for those explicity mentioned under the NOTNUMP property above. Thus
;;; (NOT (GET x 'ACS)) is a general test for potentially-random side-effects.
(MAPC '(LAMBDA (DATA)
(MAPC '(LAMBDA (X) (AND (SYSP X) (PUTPROP X (CADAR DATA) (CAAR DATA))))
(CDR DATA)))
'(
((ACS 1) IN OUT CLOSE LINEL PAGEL CHARPOS LINENUM PAGENUM
CLEAR-INPUT CLEAR-OUTPUT FORCE-OUTPUT NAMELIST
TRUENAME PROBEF DELETEF DEFAULTF FASLP)
((ACS 2) MERGEF)
((ACS 3) NAMESTRING SHORTNAMESTRING)
((ACS 4) RUBOUT RENAMEF ENDPAGEFN EOFFN FILEP DELETEF FILEPOS
LENGTHF CNAMEF)
((ACS 5) OPEN)
;Missing are INCLUDE and LOAD, because they may cause
; totally unforseen side-effects
((ACS 1) LENGTH ADD1 SUB1 MINUS ABS FLOAT FIX
SIN COS SQRT LOG EXP ZEROP PLUSP MINUSP ODDP
1+ 1- 1+/$ 1-/$)
((ACS 1) LAST SLEEP RANDOM NOINTERRUPT EXAMINE
ARG MUNKAM ERRFRAME)
((ACS 2) PLUS TIMES EXPT DIFFERENCE QUOTIENT MAX MIN
GREATERP LESSP ATAN
*PLUS *TIMES *GREAT *QUO *DIF *LESS /\/\ /↑ /↑$
HAULONG HAIPART GCD BOOLE REMAINDER)
((ACS 2) GET REMPROP MEMQ RECLAIM EQUAL DEPOSIT
CONS NCONS XCONS SUBLIS NCONC *NCONC *DELQ
DELQ ASSQ ALARMCLOCK SETARG SETPLIST MAKNUM
SAMEPNAMEP ALPHALESSP GETCHARN MAKNAM LISTIFY
NTH NTHCDR)
((ACS 3) GENSYM FLATSIZE FLATC PNGET EVALFRAME PURIFY
LISTARRAY FILLARRAY DUMPARRAYS ARRAYDIMS
PRINT PRIN1 PRINC *PRINT *PRIN1 *PRINC
SYSP COPYSYMBOL SXHASH
REVERSE NREVERSE NRECONC GETL PUTPROP ARGS)
((ACS 4) ASSOC SASSOC SASSQ CRUNIT)
((ACS 4) %HUNK1 %HUNK2 %HUNK3 %HUNK4)
((ACS 5) SUBST *DELETE DELETE MEMBER *APPEND APPEND
*ARRAY *REARRAY LOADARRAYS
BAKTRACE BAKLIST ERRPRINT
ALLOC *FUNCTION SUSPEND SETSYNTAX
EXPLODEC EXPLODE EXPLODEN
PNPUT INTERN IMPLODE REMOB ASCII READCH *READCH
*TERPRI TERPRI *TYO TYO /+TYO *TYI TYI TYIPEEK
CURSORPOS
GETMIDASOP GETDDTSYM PUTDDTSYM
UREAD UWRITE UKILL UFILE UPROBE UCLOSE UAPPEND
)))
;EVAL, *EVAL, READ, *READ and MAP series aren't here, since
; they permint random evaluations [hence random side effects]
;PAGEBPORG isn't here since it setqs BPORG, and may cause a GC.
(MAPC '(LAMBDA (INST) (PUTPROP INST 'T 'P1BOOL1ABLE))
'(AND OR NULL NOT EQ = > < COND MEMQ SIGNP))
(MAPC '(LAMBDA (INST) (PUTPROP INST 'NUMBERP 'P1BOOL1ABLE))
'(EQUAL GREATERP LESSP ODDP *GREAT *LESS ZEROP PLUSP MINUSP))
(MAPC '(LAMBDA (INST INSTN)
(PUTPROP INST
(CONS (CONS 'TLNN INSTN) (CONS 'TLNE INSTN))
'P1BOOL1ABLE))
'(ATOM NUMBERP FIXP FLOATP BIGP HUNKP SYMBOLP)
;(175700 161400 121000 40400 20000 20 10000)
'(64448. 58112. 41472. 16640. 8192. 16. 4096.))
(MAPC '(LAMBDA (INST) (PUTPROP INST 'T 'CONTAGIOUS))
'(PLUS TIMES DIFFERENCE QUOTIENT *PLUS *TIMES *DIF *QUO))
(MAPC '(LAMBDA (INST) (PUTPROP INST 'T 'NUMBERP))
'(PLUS TIMES DIFFERENCE QUOTIENT *PLUS *TIMES *DIF *QUO
ABS MINUS FIX FLOAT IFIX ADD1 SUB1 REMAINDER HAULONG))
(MAPC '(LAMBDA (INST) (PUTPROP INST 'NOTYPE 'NUMBERP))
'(GREATERP LESSP *GREAT *LESS EQ EQUAL ODDP ZEROP PLUSP MINUSP))
(MAPC '(LAMBDA (X) (PUTPROP (CAR X) (CDR X) 'ARITHP))
'( (/+ PLUS FIXNUM) (+$ PLUS FLONUM)
(/- DIFFERENCE FIXNUM) (-$ DIFFERENCE FLONUM)
(/* TIMES FIXNUM) (*$ TIMES FLONUM)
(/1+ ADD1 FIXNUM) (1+$ ADD1 FLONUM)
(/1- SUB1 FIXNUM) (1-$ SUB1 FLONUM)
(// QUOTIENT FIXNUM) (//$ QUOTIENT FLONUM)
(/> GREATERP () ) (/< LESSP () )
(/\ REMAINDER FIXNUM) (/= EQUAL () )))
)
β